home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / rdelim.scm < prev    next >
Text File  |  1995-10-22  |  10KB  |  280 lines
  1. ;;; Delimited readers
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;; These procedures run their inner I/O loop in a C primitive, so they
  4. ;;; should be quite fast.
  5. ;;;
  6. ;;; N.B.:
  7. ;;; The C primitive %READ-DELIMITED-FDPORT!/ERRNO relies on knowing the
  8. ;;; representation of character sets. If these are changed from their
  9. ;;; current representation as 256-element strings, this code must be changed
  10. ;;; as well. 
  11.  
  12. ;;; (read-delimited delims [port delim-action])
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ;;; Returns a string or the EOF object. DELIM-ACTION determines what to do
  15. ;;; with the terminating delimiter:
  16. ;;; - PEEK
  17. ;;;   Leave it in the input stream for later reading.
  18. ;;; - TRIM (the default)
  19. ;;;   Drop it on the floor.
  20. ;;; - CONCAT
  21. ;;;   Append it to the returned string.
  22. ;;; - SPLIT
  23. ;;;   Return it as a second return value.
  24. ;;;
  25. ;;; We repeatedly allocate a buffer and fill it with READ-DELIMITED!
  26. ;;; until we hit a delimiter or EOF. Each time through the loop, we
  27. ;;; double the total buffer space, so the loop terminates with a log
  28. ;;; number of reads, but uses at most double the optimal buffer space.
  29.  
  30. (define (read-delimited delims . args)
  31.   (receive (port delim-action)
  32.            (parse-optionals args (current-input-port) 'trim)
  33.  
  34.     (let ((substr (lambda (s end)        ; Smart substring.
  35.             (if (= end (string-length s)) s
  36.             (substring s 0 end))))
  37.       (delims (->char-set delims))
  38.       (gobble? (not (eq? delim-action 'peek))))
  39.     
  40.       ;; BUFLEN is total amount of buffer space allocated to date.
  41.       (let lp ((strs '()) (buflen 80) (buf (make-string 80)))
  42.     (receive (terminator num-read)
  43.              (%read-delimited! delims buf gobble? port)
  44.       (if terminator
  45.  
  46.           ;; We are done. NUM-READ is either a read count or EOF.
  47.           (let ((retval (if (and (zero? num-read)
  48.                      (eof-object? terminator)
  49.                      (null? strs))
  50.                 terminator        ; EOF -- got nothing.
  51.  
  52.                 ;; Got something. Stick all the strings
  53.                 ;; together, plus the terminator if the
  54.                 ;; client said 'CONCAT.
  55.                 (let ((s (substr buf num-read)))
  56.                   (cond ((and (eq? delim-action 'concat)
  57.                           (char? terminator))
  58.                      (apply string-append
  59.                         (reverse `(,(string terminator)
  60.                                ,s . ,strs))))
  61.  
  62.                     ((null? strs) s)    ; Gratuitous opt.
  63.                     (else (apply string-append
  64.                              (reverse (cons s strs)))))))))
  65.         (if (eq? delim-action 'split)
  66.             (values retval terminator)
  67.             retval))
  68.  
  69.           ;; We are not done. Loop and read in some more.
  70.           (lp (cons buf strs)
  71.           (+ buflen buflen)
  72.           (make-string buflen))))))))
  73.  
  74.  
  75. ;;; (read-delimited! delims buf [port delim-action start end])
  76. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77. ;;; Returns:
  78. ;;; - EOF if at end of file, and a non-zero read was requested.
  79. ;;; - Integer j if that many chars read into BUF.
  80. ;;; - #f if the buffer was filled w/o finding a delimiter.
  81. ;;;
  82. ;;; DELIM-ACTION determines what to do with the terminating delimiter;
  83. ;;; it is as in READ-DELIMITED.
  84. ;;;
  85. ;;; In determining the return value, there is an ambiguous case: when the 
  86. ;;; buffer is full, *and* the following char is a delimiter char or EOF.
  87. ;;; Ties are broken favoring termination over #f -- after filling the buffer,
  88. ;;; READ-DELIMITED! won't return #f until it has peeked one past the end
  89. ;;; of the buffer to ensure the next char doesn't terminate input (or is EOF).
  90. ;;; However, this rule is relaxed with delim-action = CONCAT -- if the buffer
  91. ;;; is full, READ-DELIMITED! won't wait around trying to peek at the following
  92. ;;; char to determine whether or not it is a delimiter char, since it doesn't
  93. ;;; have space to store the character anyway. It simply immediately returns #f;
  94. ;;; a following read can pick up the delimiter char.
  95.  
  96. (define (read-delimited! delims buf . args) ; [port delim-action start end]
  97.   (receive (port delim-action start end)
  98.            (parse-optionals args (current-input-port) 'peek
  99.                 0 (string-length buf))
  100.  
  101.     (receive (terminator num-read)
  102.          (%read-delimited! delims buf
  103.                    (not (eq? delim-action 'peek)) ;Gobble delim?
  104.                    port
  105.                    start
  106.                    (if (eq? delim-action 'concat)
  107.                    (- end 1) ; Room for terminator.
  108.                    end))
  109.  
  110.       (if terminator    ; Check for buffer overflow.
  111.       (let ((retval (if (and (eof-object? terminator)
  112.                  (zero? num-read))
  113.                 terminator    ; EOF -- got nothing.
  114.                 num-read))) ; Got something.
  115.  
  116.         (case delim-action
  117.           ((split)    (values retval terminator))
  118.           ((peek trim)    retval)
  119.           ((concat)    (cond ((char? terminator)
  120.                    (string-set! buf (+ start num-read) terminator)
  121.                    (+ num-read 1))
  122.                   (else retval)))))
  123.  
  124.       ;; Buffer overflow.
  125.       (case delim-action
  126.         ((split)     (values #f #f))
  127.         ((peek trim) #f)
  128.         ((concat)    (let ((last (read-char port)))
  129.                (if (char? last)
  130.                    (string-set! buf (+ start num-read) last))
  131.                (and (or (eof-object? last)
  132.                     (char-set-contains? (->char-set delims)
  133.                             last))
  134.                 (+ num-read 1)))))))))
  135.           
  136.  
  137. ;;; (%read-delimited! delims buf gobble? [port start end])
  138. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  139. ;;; This low-level routine uses a different interface. It returns two values:
  140. ;;; - TERMINATOR: A value describing why the read was terminated:
  141. ;;;   + character or eof-object => read terminated by this value; 
  142. ;;;   + #f                      => filled buffer w/o terminating read.
  143. ;;; - NUM-READ: Number of chars read into buf.
  144. ;;; 
  145. ;;; Note:
  146. ;;; - Invariant: TERMINATOR = #f  =>  NUM-READ = END - START.
  147. ;;; - Invariant: TERMINATOR = eof-object and NUM-READ = 0 => at EOF.
  148. ;;; - When determining the TERMINATOR return value, ties are broken
  149. ;;;   favoring character or the eof-object over #f. That is, if the buffer
  150. ;;;   fills up, %READ-DELIMITED! will peek at one more character from the
  151. ;;;   input stream to determine if it terminates the input. If so, that
  152. ;;;   is returned, not #f.
  153. ;;;
  154. ;;; If GOBBLE? is true, then a terminator character is removed from
  155. ;;; the input stream. Otherwise, it is left in place for a following input
  156. ;;; operation.
  157.  
  158. (define (%read-delimited! delims buf gobble? . args)
  159.   (receive (port start end)
  160.        (parse-optionals args (current-input-port) 0 (string-length buf))
  161.  
  162.     (check-arg input-port? port %read-delimited!)    ; Arg checking.
  163.     (check-arg char-set? delims %read-delimited!)    ; Required, since
  164.     (if (bogus-substring-spec? buf start end)        ; we're calling C.
  165.     (error "Illegal START/END substring indices"
  166.            buf start end %read-delimited!))
  167.  
  168.     (let ((delims (->char-set delims)))
  169.  
  170.       (if (fdport? port)
  171.  
  172.       ;; Direct C support for Unix file ports -- zippy quick.
  173.       (receive (terminator num-read)
  174.                (%read-delimited-fdport!/errno delims buf gobble?
  175.                           port start end)
  176.         (if (integer? terminator)
  177.         (errno-error terminator %read-delimited! num-read
  178.                  delims buf gobble? port start end)
  179.         (values terminator num-read)))
  180.  
  181.       ;; This is the code for other kinds of ports.
  182.       ;; Mighty slow -- we read each char twice (peek first, then read).
  183.       (let lp ((i start))
  184.         (let ((c (peek-char port)))
  185.           (cond ((or (eof-object? c)    ; Found terminating char or eof
  186.              (char-set-contains? delims c))
  187.              (if gobble? (read-char port))
  188.              (values c (- i start)))
  189.  
  190.             ((>= i end)            ; Filled the buffer.
  191.              (if gobble? (read-char port))
  192.              (values #f (- i start)))
  193.             
  194.             (else (string-set! buf i (read-char port))
  195.               (lp (+ i 1))))))))))
  196.  
  197.  
  198. (foreign-source
  199.   "#include <sys/types.h>"
  200.   ""
  201.   "/* Make sure foreign-function stubs interface to the C funs correctly: */"
  202.   "#include \"fdports1.h\""
  203.   "" "")
  204.  
  205. (define-foreign %read-delimited-fdport!/errno (read_delim (string delims)
  206.                               (var-string buf)
  207.                               (bool gobble?)
  208.                               (desc port)
  209.                               (fixnum start)
  210.                               (fixnum end))
  211.   desc    ; int => errno; char => terminating char; eof-object; #f => buf ovflow
  212.   fixnum)   ; number of chars read into BUF.
  213.  
  214.  
  215. ;;; This is probably a hell of lot slower than actually reading the string
  216. ;;; into a buffer and throwing it away, due to the painful slowness of
  217. ;;; the current char-at-a-time Scheme input.
  218.  
  219. (define (skip-char-set cset . maybe-port)
  220.   (let ((port (optional-arg maybe-port (current-input-port))))
  221.     (let lp ()
  222.       (let ((c (peek-char port)))
  223.     (cond ((and (char? c) (char-set-contains? cset c))
  224.            (read-char port)
  225.            (lp))
  226.           (else c))))))
  227.  
  228.  
  229. ;;; (read-line [port delim-action])
  230. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  231. ;;; Read in a line of data. Input is terminated by either a newline or EOF.
  232. ;;; The newline is trimmed from the string by default.
  233.  
  234. (define charset:newline (char-set #\newline))
  235.  
  236. (define (read-line . rest)
  237.   (receive (port delim-action)
  238.            (parse-optionals rest (current-input-port) 'trim)
  239.     (read-delimited charset:newline port delim-action)))
  240.  
  241.  
  242. ;;; (read-paragraph [port handle-delim])
  243. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  244.  
  245. (define blank-line-regexp (make-regexp "^[ \t]*\n$"))
  246.  
  247. (define (read-paragraph . args)
  248.   (receive (port handle-delim)
  249.            (parse-optionals args (current-input-port) 'trim)
  250.     
  251.     ;; First, skip all blank lines.
  252.     (let lp ()
  253.       (let ((line (read-line port 'concat)))
  254.     (cond ((eof-object? line)
  255.            (if (eq? handle-delim 'split) (values line line) line))
  256.  
  257.           ((regexp-exec blank-line-regexp line) (lp))
  258.  
  259.           ;; Then, read in non-blank lines.
  260.           (else
  261.            (let lp ((lines (list line)))
  262.          (let ((line (read-line port 'concat)))
  263.            (if (and (string? line)
  264.                 (not (regexp-exec blank-line-regexp line)))
  265.  
  266.                (lp (cons line lines))
  267.  
  268.                ;; Return the paragraph
  269.                (let ((->str (lambda (lns) (apply string-append (reverse lns)))))
  270.              (case handle-delim
  271.                ((trim) (->str lines))
  272.  
  273.                ((concat)
  274.                 (->str (if (eof-object? line) lines (cons line lines))))
  275.  
  276.                ((split)
  277.                 (values (->str lines) line))
  278.  
  279.                (else (error "Illegal HANDLE-DELIM parameter to READ-PARAGRAPH")))))))))))))
  280.